The X-Philes (2nd Revision)/The X-Philes Number 1 (1995).iso/xphiles/hp48hor2/cmat.src

Text File | 1992-08-18 | 4KB | 127 lines

%%HP: T(3)A(R)F(.);
@ CMAT: HP48 program to apply expressions to columns of a matrix.
@       03/22/91 Version 1.0
@       Wes Hubert <wes at kuhub.cc.ukans.edu>
@
@ CMAT provides operations on matrix columns.  To use it, place a matrix on
@ level 2 of the stack, and an algebraic equation object or command list
@ on level 1 of the stack.  (See external documentation for information
@ about command lists.)  The equation should be of the form:
@ 'Ci=expression', where "Ci" specifies the column where the
@ result should be placed, and "expression" uses "C1, C2, ... Cn" to
@ specify columns 1, 2, ... n of the matrix.  For example:
@   [[1 2] [3 4] [5 6]]
@   'C1=C2^2+C1'
@ would return:
@   [[5 2] [19 4] [41 6]]
@
@ If the output column is not in the original matrix, the matrix will be
@ expanded to include enough new columns to store it, filling any new
@ unreferenced columns with zero.  For example, if the equation for
@ the input matrix above were 'C4=C2^2+C1', the result would be:
@   [[1 2 0 5] [3 4 0 19] [5 6 0 41]]
@
@ CMAT creates a working directory, stores variables into it, and
@ purges the directory when it finishes.  It includes rudimentary error
@ trapping to purge the working directory even if it does not run to
@ completion.
@
DIR
CMAT                                @ Protect environment from data errors
    \<< 'WRKTAB' CRDIR WRKTAB
      IFERR CMAIN
      THEN UPDIR 'WRKTAB' PGDIR ERRM DOERR
      ELSE UPDIR 'WRKTAB' PGDIR
      END
    \>>
CMAIN                               @ Main program for column processing
   \<<
     { } 'NAMES' STO
     IF DUP TYPE 5 \=/
     THEN 1 \->LIST
     END
     'FLIST' STO
     1 FLIST SIZE
     FOR elt FLIST elt GET
       IF CPARSE
       THEN CCOND
           CRESULT
           CADJUST
           1 NR
           FOR ir
               ir 'CASEID' STO 1 NC
               FOR ic ir ic 2 \->LIST
                   GETI SWAP DROP
                   NAMES ic GET STO
               NEXT
               IF CTST
               THEN FORM EVAL \->NUM ir
                    RESULT 2 \->LIST SWAP PUT
               END
           NEXT
        END
     NEXT
   \>>
CPARSE                              @ Scan item from command list.
    \<<
      IF DUP TYPE 5 \=/                      @ If not a list,
      THEN 1                                 @   treat as algebraic equation
      ELSE DUP 1 GET 1 1 SUB                 @ Check first char of keyword
        CASE DUP "N" ==                      @ "NAMELIST"
          THEN DROP 2 99 SUB CNL 0           @   Process in CNL, return 0
          END DUP "I" ==                     @ "IF"
          THEN DROP DUP 3 GET SWAP 2 GET 1   @   Return equation & condition
          END "C" ==                         @ "COMPUTE"
          THEN 2 GET 1                       @   Return equation only
          END
        END
      END
    \>>
CNL                                 @ Process namelist {{position name}...}
    \<<
      IF DUP TYPE 5 ==
      THEN 1 OVER SIZE
        FOR i DUP i GET 1 GETI
          IF DUP NAMES SIZE >
          THEN NAMES SIZE 1 + OVER
            FOR i NAMES "C" i +              @ Default name C+column#
              # 5B15h SYSEVAL + 'NAMES' STO  @ String to variable name
            NEXT
          END
          ROT ROT GET NAMES ROT
          ROT PUT 'NAMES' STO
        NEXT
      END DROP
    \>>
CCOND                              @ Process conditional part, if present
    \<<
      IF DUP \->STR DUP "=" POS SWAP
         "==" POS NOT AND
      THEN 1                                 @ Default is TRUE (1)
      END 'CTST' STO
    \>>
CRESULT                            @ Save result column # in RESULT
    \<<
      OBJ\-> DROP2 'FORM' STO
      IF NAMES OVER POS DUP
      THEN SWAP DROP
      ELSE DROP \->STR 3 OVER
      SIZE 1 - SUB OBJ\->
      END 'RESULT' STO
    \>>
CADJUST                            @ Add columns to matrix and names
    \<<
      DUP SIZE DUP 1 GET 'NR' STO
      2 GET 'NC' STO
      IF NC RESULT <
      THEN TRN RESULT NR 2
           \->LIST RDM TRN
      END
      NAMES DUP SIZE 1 + NC
      FOR i
          "C" i + # 5B15h SYSEVAL +
      NEXT
     'NAMES' STO
    \>>
END